home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / jka-compr.el.z / jka-compr.el
Encoding:
Text File  |  1998-10-28  |  25.2 KB  |  842 lines
  1. ;;; jka-compr.el --- reading/writing/loading compressed files
  2.  
  3. ;; Copyright (C) 1993, 1994  Free Software Foundation, Inc.
  4.  
  5. ;; Author: jka@ece.cmu.edu (Jay K. Adams)
  6. ;; Keywords: data
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Commentary: 
  26.  
  27. ;; This package implements low-level support for reading, writing,
  28. ;; and loading compressed files.  It hooks into the low-level file
  29. ;; I/O functions (including write-region and insert-file-contents) so
  30. ;; that they automatically compress or uncompress a file if the file
  31. ;; appears to need it (based on the extension of the file name).
  32. ;; Packages like Rmail, VM, GNUS, and Info should be able to work
  33. ;; with compressed files without modification.
  34.  
  35.  
  36. ;; INSTRUCTIONS:
  37. ;;
  38. ;; To use jka-compr, simply load this package, and edit as usual.
  39. ;; Its operation should be transparent to the user (except for
  40. ;; messages appearing when a file is being compressed or
  41. ;; uncompressed).
  42. ;;
  43. ;; The variable, jka-compr-compression-info-list can be used to
  44. ;; customize jka-compr to work with other compression programs.
  45. ;; The default value of this variable allows jka-compr to work with
  46. ;; Unix compress and gzip.
  47. ;;
  48. ;; If you are concerned about the stderr output of gzip and other
  49. ;; compression/decompression programs showing up in your buffers, you
  50. ;; should set the discard-error flag in the compression-info-list.
  51. ;; This will cause the stderr of all programs to be discarded.
  52. ;; However, it also causes emacs to call compression/uncompression
  53. ;; programs through a shell (which is specified by jka-compr-shell).
  54. ;; This may be a drag if, on your system, starting up a shell is
  55. ;; slow.
  56. ;;
  57. ;; If you don't want messages about compressing and decompressing
  58. ;; to show up in the echo area, you can set the compress-name and
  59. ;; decompress-name fields of the jka-compr-compression-info-list to
  60. ;; nil.
  61.  
  62.  
  63. ;; APPLICATION NOTES:
  64. ;;
  65. ;; crypt++
  66. ;;   jka-compr can coexist with crpyt++ if you take all the decompression
  67. ;;   entries out of the crypt-encoding-list.  Clearly problems will arise if
  68. ;;   you have two programs trying to compress/decompress files.  jka-compr
  69. ;;   will not "work with" crypt++ in the following sense: you won't be able to
  70. ;;   decode encrypted compressed files--that is, files that have been
  71. ;;   compressed then encrypted (in that order).  Theoretically, crypt++ and
  72. ;;   jka-compr could properly handle a file that has been encrypted then
  73. ;;   compressed, but there is little point in trying to compress an encrypted
  74. ;;   file.
  75. ;;
  76.  
  77.  
  78. ;; ACKNOWLEDGMENTS
  79. ;; 
  80. ;; jka-compr is a V19 adaptation of jka-compr for V18 of Emacs.  Many people
  81. ;; have made helpful suggestions, reported bugs, and even fixed bugs in 
  82. ;; jka-compr.  I recall the following people as being particularly helpful.
  83. ;;
  84. ;;   Jean-loup Gailly
  85. ;;   David Hughes
  86. ;;   Richard Pieri
  87. ;;   Daniel Quinlan
  88. ;;   Chris P. Ross
  89. ;;   Rick Sladkey
  90. ;;
  91. ;; Andy Norman's ange-ftp was the inspiration for the original jka-compr for
  92. ;; Version 18 of Emacs.
  93. ;;
  94. ;; After I had made progress on the original jka-compr for V18, I learned of a
  95. ;; package written by Kazushi Jam Marukawa, called jam-zcat, that did exactly
  96. ;; what I was trying to do.  I looked over the jam-zcat source code and
  97. ;; probably got some ideas from it.
  98. ;;
  99.  
  100. ;;; Code:
  101.  
  102. (defvar jka-compr-shell "sh"
  103.   "*Shell to be used for calling compression programs.
  104. The value of this variable only matters if you want to discard the
  105. stderr of a compression/decompression program (see the documentation
  106. for `jka-compr-compression-info-list').")
  107.  
  108.  
  109. (defvar jka-compr-use-shell t)
  110.  
  111.  
  112. ;;; I have this defined so that .Z files are assumed to be in unix
  113. ;;; compress format; and .gz files, in gzip format.
  114. (defvar jka-compr-compression-info-list
  115.   ;;[regexp
  116.   ;; compr-message  compr-prog  compr-args
  117.   ;; uncomp-message uncomp-prog uncomp-args
  118.   ;; can-append auto-mode-flag]
  119.   '(["\\.Z\\(~\\|\\.~[0-9]+~\\)?\\'"
  120.      "compressing"    "compress"     ("-c")
  121.      "uncompressing"  "uncompress"   ("-c")
  122.      nil t]
  123.     ["\\.tgz\\'"
  124.      "zipping"        "gzip"         ("-c" "-q")
  125.      "unzipping"      "gzip"         ("-c" "-q" "-d")
  126.      t nil]
  127.     ["\\.gz\\(~\\|\\.~[0-9]+~\\)?\\'"
  128.      "zipping"        "gzip"         ("-c" "-q")
  129.      "unzipping"      "gzip"         ("-c" "-q" "-d")
  130.      t t])
  131.  
  132.   "List of vectors that describe available compression techniques.
  133. Each element, which describes a compression technique, is a vector of
  134. the form [REGEXP COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS
  135. UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS
  136. APPEND-FLAG EXTENSION], where:
  137.  
  138.    regexp                is a regexp that matches filenames that are
  139.                          compressed with this format
  140.  
  141.    compress-msg          is the message to issue to the user when doing this
  142.                          type of compression (nil means no message)
  143.  
  144.    compress-program      is a program that performs this compression
  145.  
  146.    compress-args         is a list of args to pass to the compress program
  147.  
  148.    uncompress-msg        is the message to issue to the user when doing this
  149.                          type of uncompression (nil means no message)
  150.  
  151.    uncompress-program    is a program that performs this compression
  152.  
  153.    uncompress-args       is a list of args to pass to the uncompress program
  154.  
  155.    append-flag           is non-nil if this compression technique can be
  156.                          appended
  157.  
  158.    auto-mode flag        non-nil means strip the regexp from file names
  159.                          before attempting to set the mode.
  160.  
  161. Because of the way `call-process' is defined, discarding the stderr output of
  162. a program adds the overhead of starting a shell each time the program is
  163. invoked.")
  164.  
  165. (defvar jka-compr-mode-alist-additions
  166.   (list (cons "\\.tgz\\'" 'tar-mode))
  167.   "A list of pairs to add to auto-mode-alist when jka-compr is installed.")
  168.  
  169. (defvar jka-compr-file-name-handler-entry
  170.   nil
  171.   "The entry in `file-name-handler-alist' used by the jka-compr I/O functions.")
  172.  
  173. ;;; Functions for accessing the return value of jka-compr-get-compression-info
  174. (defun jka-compr-info-regexp               (info)  (aref info 0))
  175. (defun jka-compr-info-compress-message     (info)  (aref info 1))
  176. (defun jka-compr-info-compress-program     (info)  (aref info 2))
  177. (defun jka-compr-info-compress-args        (info)  (aref info 3))
  178. (defun jka-compr-info-uncompress-message   (info)  (aref info 4))
  179. (defun jka-compr-info-uncompress-program   (info)  (aref info 5))
  180. (defun jka-compr-info-uncompress-args      (info)  (aref info 6))
  181. (defun jka-compr-info-can-append           (info)  (aref info 7))
  182. (defun jka-compr-info-strip-extension      (info)  (aref info 8))
  183.  
  184.  
  185. (defun jka-compr-get-compression-info (filename)
  186.   "Return information about the compression scheme of FILENAME.
  187. The determination as to which compression scheme, if any, to use is
  188. based on the filename itself and `jka-compr-compression-info-list'."
  189.   (catch 'compression-info
  190.     (let ((case-fold-search nil))
  191.       (mapcar
  192.        (function (lambda (x)
  193.            (and (string-match (jka-compr-info-regexp x) filename)
  194.             (throw 'compression-info x))))
  195.        jka-compr-compression-info-list)
  196.       nil)))
  197.  
  198.  
  199. (put 'compression-error 'error-conditions '(compression-error file-error error))
  200.  
  201.  
  202. (defvar jka-compr-acceptable-retval-list '(0 2 141))
  203.  
  204.  
  205. (defun jka-compr-error (prog args infile message &optional errfile)
  206.  
  207.   (let ((errbuf (get-buffer-create " *jka-compr-error*"))
  208.     (curbuf (current-buffer)))
  209.     (set-buffer errbuf)
  210.     (widen) (erase-buffer)
  211.     (insert (format "Error while executing \"%s %s < %s\"\n\n"
  212.              prog
  213.              (mapconcat 'identity args " ")
  214.              infile))
  215.  
  216.      (and errfile
  217.       (insert-file-contents errfile))
  218.  
  219.      (set-buffer curbuf)
  220.      (display-buffer errbuf))
  221.  
  222.   (signal 'compression-error (list "Opening input file" (format "error %s" message) infile)))
  223.             
  224.    
  225. (defvar jka-compr-dd-program
  226.   "/bin/dd")
  227.  
  228.  
  229. (defvar jka-compr-dd-blocksize 256)
  230.  
  231.  
  232. (defun jka-compr-partial-uncompress (prog message args infile beg len)
  233.   "Call program PROG with ARGS args taking input from INFILE.
  234. Fourth and fifth args, BEG and LEN, specify which part of the output
  235. to keep: LEN chars starting BEG chars from the beginning."
  236.   (let* ((skip (/ beg jka-compr-dd-blocksize))
  237.      (prefix (- beg (* skip jka-compr-dd-blocksize)))
  238.      (count (and len (1+ (/ (+ len prefix) jka-compr-dd-blocksize))))
  239.      (start (point))
  240.      (err-file (jka-compr-make-temp-name))
  241.      (run-string (format "%s %s 2> %s | %s bs=%d skip=%d %s 2> /dev/null"
  242.                  prog
  243.                  (mapconcat 'identity args " ")
  244.                  err-file
  245.                  jka-compr-dd-program
  246.                  jka-compr-dd-blocksize
  247.                  skip
  248.                  ;; dd seems to be unreliable about
  249.                  ;; providing the last block.  So, always
  250.                  ;; read one more than you think you need.
  251.                  (if count (concat "count=" (1+ count)) ""))))
  252.  
  253.     (unwind-protect
  254.     (or (memq (call-process jka-compr-shell
  255.                 infile t nil "-c"
  256.                 run-string)
  257.           jka-compr-acceptable-retval-list)
  258.         
  259.         (jka-compr-error prog args infile message err-file))
  260.  
  261.       (jka-compr-delete-temp-file err-file))
  262.  
  263.     ;; Delete the stuff after what we want, if there is any.
  264.     (and
  265.      len
  266.      (< (+ start prefix len) (point))
  267.      (delete-region (+ start prefix len) (point)))
  268.  
  269.     ;; Delete the stuff before what we want.
  270.     (delete-region start (+ start prefix))))
  271.  
  272.  
  273. (defun jka-compr-call-process (prog message infile output temp args)
  274.   (if jka-compr-use-shell
  275.  
  276.       (let ((err-file (jka-compr-make-temp-name)))
  277.         
  278.     (unwind-protect
  279.  
  280.         (or (memq
  281.          (call-process jka-compr-shell infile
  282.                    (if (stringp output) nil output)
  283.                    nil
  284.                    "-c"
  285.                    (format "%s %s 2> %s %s"
  286.                        prog
  287.                        (mapconcat 'identity args " ")
  288.                        err-file
  289.                        (if (stringp output)
  290.                        (concat "> " output)
  291.                      "")))
  292.          jka-compr-acceptable-retval-list)
  293.  
  294.         (jka-compr-error prog args infile message err-file))
  295.  
  296.       (jka-compr-delete-temp-file err-file)))
  297.  
  298.     (or (zerop
  299.      (apply 'call-process
  300.         prog
  301.         infile
  302.         (if (stringp output) temp output)
  303.         nil
  304.         args))
  305.     (jka-compr-error prog args infile message))
  306.  
  307.     (and (stringp output)
  308.      (let ((cbuf (current-buffer)))
  309.        (set-buffer temp)
  310.        (write-region (point-min) (point-max) output)
  311.        (erase-buffer)
  312.        (set-buffer cbuf)))))
  313.  
  314.  
  315. ;;; Support for temp files.  Much of this was inspired if not lifted
  316. ;;; from ange-ftp.
  317.  
  318. (defvar jka-compr-temp-name-template
  319.   "/tmp/jka-com"
  320.   "Prefix added to all temp files created by jka-compr.
  321. There should be no more than seven characters after the final `/'")
  322.  
  323. (defvar jka-compr-temp-name-table (make-vector 31 nil))
  324.  
  325. (defun jka-compr-make-temp-name (&optional local-copy)
  326.   "This routine will return the name of a new file."
  327.   (let* ((lastchar ?a)
  328.      (prevchar ?a)
  329.      (template (concat jka-compr-temp-name-template "aa"))
  330.      (lastpos (1- (length template)))
  331.      (not-done t)
  332.      file
  333.      entry)
  334.  
  335.     (while not-done
  336.       (aset template lastpos lastchar)
  337.       (setq file (concat (make-temp-name template) "#"))
  338.       (setq entry (intern file jka-compr-temp-name-table))
  339.       (if (or (get entry 'active)
  340.           (file-exists-p file))
  341.  
  342.       (progn
  343.         (setq lastchar (1+ lastchar))
  344.         (if (> lastchar ?z)
  345.         (progn
  346.           (setq prevchar (1+ prevchar))
  347.           (setq lastchar ?a)
  348.           (if (> prevchar ?z)
  349.               (error "Can't allocate temp file.")
  350.             (aset template (1- lastpos) prevchar)))))
  351.  
  352.     (put entry 'active (not local-copy))
  353.     (setq not-done nil)))
  354.  
  355.     file))
  356.  
  357.  
  358. (defun jka-compr-delete-temp-file (temp)
  359.  
  360.   (put (intern temp jka-compr-temp-name-table)
  361.        'active nil)
  362.  
  363.   (condition-case ()
  364.       (delete-file temp)
  365.     (error nil)))
  366.  
  367.  
  368. (defun jka-compr-write-region (start end file &optional append visit)
  369.   (let* ((filename (expand-file-name file))
  370.      (visit-file (if (stringp visit) (expand-file-name visit) filename))
  371.      (info (jka-compr-get-compression-info visit-file)))
  372.       
  373.       (if info
  374.  
  375.       (let ((can-append (jka-compr-info-can-append info))
  376.         (compress-program (jka-compr-info-compress-program info))
  377.         (compress-message (jka-compr-info-compress-message info))
  378.         (uncompress-program (jka-compr-info-uncompress-program info))
  379.         (uncompress-message (jka-compr-info-uncompress-message info))
  380.         (compress-args (jka-compr-info-compress-args info))
  381.         (uncompress-args (jka-compr-info-uncompress-args info))
  382.         (base-name (file-name-nondirectory visit-file))
  383.         temp-file cbuf temp-buffer)
  384.  
  385.         (setq cbuf (current-buffer)
  386.           temp-buffer (get-buffer-create " *jka-compr-wr-temp*"))
  387.         (set-buffer temp-buffer)
  388.         (widen) (erase-buffer)
  389.         (set-buffer cbuf)
  390.  
  391.         (if (and append
  392.              (not can-append)
  393.              (file-exists-p filename))
  394.         
  395.         (let* ((local-copy (file-local-copy filename))
  396.                (local-file (or local-copy filename)))
  397.           
  398.           (setq temp-file local-file))
  399.  
  400.           (setq temp-file (jka-compr-make-temp-name)))
  401.  
  402.         (and 
  403.          compress-message
  404.          (message "%s %s..." compress-message base-name))
  405.         
  406.         (jka-compr-run-real-handler 'write-region
  407.                     (list start end temp-file t 'dont))
  408.  
  409.         (jka-compr-call-process compress-program
  410.                     (concat compress-message
  411.                         " " base-name)
  412.                     temp-file
  413.                     temp-buffer
  414.                     nil
  415.                     compress-args)
  416.  
  417.         (set-buffer temp-buffer)
  418.         (jka-compr-run-real-handler 'write-region
  419.                     (list (point-min) (point-max)
  420.                           filename
  421.                           (and append can-append) 'dont))
  422.         (erase-buffer)
  423.         (set-buffer cbuf)
  424.  
  425.         (jka-compr-delete-temp-file temp-file)
  426.  
  427.         (and
  428.          compress-message
  429.          (message "%s %s...done" compress-message base-name))
  430.  
  431.         (cond
  432.          ((eq visit t)
  433.           (setq buffer-file-name filename)
  434.           (set-visited-file-modtime))
  435.          ((stringp visit)
  436.           (setq buffer-file-name visit)
  437.           (let ((buffer-file-name filename))
  438.         (set-visited-file-modtime))))
  439.  
  440.         (and (or (eq visit t)
  441.              (eq visit nil)
  442.              (stringp visit))
  443.          (message "Wrote %s" visit-file))
  444.  
  445.         nil)
  446.           
  447.     (jka-compr-run-real-handler 'write-region
  448.                     (list start end filename append visit)))))
  449.  
  450.  
  451. (defun jka-compr-insert-file-contents (file &optional visit beg end replace)
  452.   (barf-if-buffer-read-only)
  453.  
  454.   (and (or beg end)
  455.        visit
  456.        (error "Attempt to visit less than an entire file"))
  457.  
  458.   (let* ((filename (expand-file-name file))
  459.      (info (jka-compr-get-compression-info filename)))
  460.  
  461.     (if info
  462.  
  463.     (let ((uncompress-message (jka-compr-info-uncompress-message info))
  464.           (uncompress-program (jka-compr-info-uncompress-program info))
  465.           (uncompress-args (jka-compr-info-uncompress-args info))
  466.           (base-name (file-name-nondirectory filename))
  467.           (notfound nil)
  468.           (local-copy
  469.            (jka-compr-run-real-handler 'file-local-copy (list filename)))
  470.           local-file
  471.           size start)
  472.  
  473.       (setq local-file (or local-copy filename))
  474.  
  475.       (and
  476.        visit
  477.        (setq buffer-file-name filename))
  478.  
  479.       (unwind-protect        ; to make sure local-copy gets deleted
  480.  
  481.           (progn
  482.           
  483.         (and
  484.          uncompress-message
  485.          (message "%s %s..." uncompress-message base-name))
  486.  
  487.         (condition-case error-code
  488.  
  489.             (progn
  490.               (if replace
  491.               (goto-char (point-min)))
  492.               (setq start (point))
  493.               (if (or beg end)
  494.               (jka-compr-partial-uncompress uncompress-program
  495.                             (concat uncompress-message
  496.                                 " " base-name)
  497.                             uncompress-args
  498.                             local-file
  499.                             (or beg 0)
  500.                             (if (and beg end)
  501.                                 (- end beg)
  502.                               end))
  503.             ;; If visiting, bind off buffer-file-name so that
  504.             ;; file-locking will not ask whether we should
  505.             ;; really edit the buffer.
  506.             (let ((buffer-file-name
  507.                    (if visit nil buffer-file-name)))
  508.               (jka-compr-call-process uncompress-program
  509.                           (concat uncompress-message
  510.                               " " base-name)
  511.                           local-file
  512.                           t
  513.                           nil
  514.                           uncompress-args)))
  515.               (setq size (- (point) start))
  516.               (if replace
  517.               (let* ((del-beg (point))
  518.                  (del-end (+ del-beg size)))
  519.                 (delete-region del-beg
  520.                        (min del-end (point-max)))))
  521.               (goto-char start))
  522.           (error
  523.            (if (and (eq (car error-code) 'file-error)
  524.                 (eq (nth 3 error-code) local-file))
  525.                (if visit
  526.                (setq notfound error-code)
  527.              (signal 'file-error 
  528.                  (cons "Opening input file"
  529.                        (nthcdr 2 error-code))))
  530.              (signal (car error-code) (cdr error-code))))))
  531.  
  532.         (and
  533.          local-copy
  534.          (file-exists-p local-copy)
  535.          (delete-file local-copy)))
  536.  
  537.       (and
  538.        visit
  539.        (progn
  540.          (unlock-buffer)
  541.          (setq buffer-file-name filename)
  542.          (set-visited-file-modtime)))
  543.         
  544.       (and
  545.        uncompress-message
  546.        (message "%s %s...done" uncompress-message base-name))
  547.  
  548.       (and
  549.        visit
  550.        notfound
  551.        (signal 'file-error
  552.            (cons "Opening input file" (nth 2 notfound))))
  553.  
  554.       ;; Run the functions that insert-file-contents would.
  555.       (let ((p after-insert-file-functions)
  556.         (insval size))
  557.         (while p
  558.           (setq insval (funcall (car p) size))
  559.           (if insval
  560.           (progn
  561.             (or (integerp insval)
  562.             (signal 'wrong-type-argument
  563.                 (list 'integerp insval)))
  564.             (setq size insval)))
  565.           (setq p (cdr p))))
  566.  
  567.       (list filename size))
  568.  
  569.       (jka-compr-run-real-handler 'insert-file-contents
  570.                   (list file visit beg end replace)))))
  571.  
  572.  
  573. (defun jka-compr-file-local-copy (file)
  574.   (let* ((filename (expand-file-name file))
  575.      (info (jka-compr-get-compression-info filename)))
  576.  
  577.     (if info
  578.  
  579.     (let ((uncompress-message (jka-compr-info-uncompress-message info))
  580.           (uncompress-program (jka-compr-info-uncompress-program info))
  581.           (uncompress-args (jka-compr-info-uncompress-args info))
  582.           (base-name (file-name-nondirectory filename))
  583.           (local-copy
  584.            (jka-compr-run-real-handler 'file-local-copy (list filename)))
  585.           (temp-file (jka-compr-make-temp-name t))
  586.           (temp-buffer (get-buffer-create " *jka-compr-flc-temp*"))
  587.           (notfound nil)
  588.           (cbuf (current-buffer))
  589.           local-file)
  590.  
  591.       (setq local-file (or local-copy filename))
  592.  
  593.       (unwind-protect
  594.  
  595.           (progn
  596.           
  597.         (and
  598.          uncompress-message
  599.          (message "%s %s..." uncompress-message base-name))
  600.  
  601.         (set-buffer temp-buffer)
  602.           
  603.         (jka-compr-call-process uncompress-program
  604.                     (concat uncompress-message
  605.                         " " base-name)
  606.                     local-file
  607.                     t
  608.                     nil
  609.                     uncompress-args)
  610.  
  611.         (and
  612.          uncompress-message
  613.          (message "%s %s...done" uncompress-message base-name))
  614.  
  615.         (write-region
  616.          (point-min) (point-max) temp-file nil 'dont))
  617.  
  618.         (and
  619.          local-copy
  620.          (file-exists-p local-copy)
  621.          (delete-file local-copy))
  622.  
  623.         (set-buffer cbuf)
  624.         (kill-buffer temp-buffer))
  625.  
  626.       temp-file)
  627.         
  628.       (jka-compr-run-real-handler 'file-local-copy (list filename)))))
  629.  
  630.  
  631. ;;; Support for loading compressed files.
  632. (defun jka-compr-load (file &optional noerror nomessage nosuffix)
  633.   "Documented as original."
  634.  
  635.   (let* ((local-copy (jka-compr-file-local-copy file))
  636.      (load-file (or local-copy file)))
  637.  
  638.     (unwind-protect
  639.  
  640.     (let (inhibit-file-name-operation
  641.           inhibit-file-name-handlers)
  642.       (or nomessage
  643.           (message "Loading %s..." file))
  644.  
  645.       (let ((load-force-doc-strings t))
  646.         (load load-file noerror t t))
  647.  
  648.       (or nomessage
  649.           (message "Loading %s...done." file)))
  650.  
  651.       (jka-compr-delete-temp-file local-copy))
  652.  
  653.     t))
  654.  
  655. (defun jka-compr-byte-compiler-base-file-name (file)
  656.   (let ((info (jka-compr-get-compression-info file)))
  657.     (if (and info (jka-compr-info-strip-extension info))
  658.     (save-match-data
  659.       (substring file 0 (string-match (jka-compr-info-regexp info) file)))
  660.       file)))
  661.  
  662. (put 'write-region 'jka-compr 'jka-compr-write-region)
  663. (put 'insert-file-contents 'jka-compr 'jka-compr-insert-file-contents)
  664. (put 'file-local-copy 'jka-compr 'jka-compr-file-local-copy)
  665. (put 'load 'jka-compr 'jka-compr-load)
  666. (put 'byte-compiler-base-file-name 'jka-compr
  667.      'jka-compr-byte-compiler-base-file-name)
  668.  
  669. (defun jka-compr-handler (operation &rest args)
  670.   (save-match-data
  671.     (let ((jka-op (get operation 'jka-compr)))
  672.       (if jka-op
  673.       (apply jka-op args)
  674.     (jka-compr-run-real-handler operation args)))))
  675.  
  676. ;; If we are given an operation that we don't handle,
  677. ;; call the Emacs primitive for that operation,
  678. ;; and manipulate the inhibit variables
  679. ;; to prevent the primitive from calling our handler again.
  680. (defun jka-compr-run-real-handler (operation args)
  681.   (let ((inhibit-file-name-handlers
  682.      (cons 'jka-compr-handler
  683.            (and (eq inhibit-file-name-operation operation)
  684.             inhibit-file-name-handlers)))
  685.     (inhibit-file-name-operation operation))
  686.     (apply operation args)))
  687.  
  688. ;;;###autoload(defun auto-compression-mode (&optional arg)
  689. ;;;###autoload  "\
  690. ;;;###autoloadToggle automatic file compression and uncompression.
  691. ;;;###autoloadWith prefix argument ARG, turn auto compression on if positive, else off.
  692. ;;;###autoloadReturns the new status of auto compression (non-nil means on)."
  693. ;;;###autoload  (interactive "P")
  694. ;;;###autoload  (if (not (fboundp 'jka-compr-installed-p))
  695. ;;;###autoload      (progn
  696. ;;;###autoload        (require 'jka-compr)
  697. ;;;###autoload        ;; That turned the mode on, so make it initially off.
  698. ;;;###autoload        (toggle-auto-compression)))
  699. ;;;###autoload  (toggle-auto-compression arg t))
  700.  
  701. (defun toggle-auto-compression (&optional arg message)
  702.   "Toggle automatic file compression and uncompression.
  703. With prefix argument ARG, turn auto compression on if positive, else off.
  704. Returns the new status of auto compression (non-nil means on).
  705. If the argument MESSAGE is non-nil, it means to print a message
  706. saying whether the mode is now on or off."
  707.   (interactive "P\np")
  708.   (let* ((installed (jka-compr-installed-p))
  709.      (flag (if (null arg)
  710.            (not installed)
  711.          (or (eq arg t) (listp arg) (and (integerp arg) (> arg 0))))))
  712.  
  713.     (cond
  714.      ((and flag installed) t)        ; already installed
  715.  
  716.      ((and (not flag) (not installed)) nil) ; already not installed
  717.  
  718.      (flag
  719.       (jka-compr-install))
  720.  
  721.      (t
  722.       (jka-compr-uninstall)))
  723.  
  724.  
  725.     (and message
  726.      (if flag
  727.          (message "Automatic file (de)compression is now ON.")
  728.        (message "Automatic file (de)compression is now OFF.")))
  729.  
  730.     flag))
  731.  
  732. (defun jka-compr-build-file-regexp ()
  733.   (concat
  734.    "\\("
  735.    (mapconcat
  736.     'jka-compr-info-regexp
  737.     jka-compr-compression-info-list
  738.     "\\)\\|\\(")
  739.    "\\)"))
  740.  
  741.  
  742. (defun jka-compr-install ()
  743.   "Install jka-compr.
  744. This adds entries to `file-name-handler-alist' and `auto-mode-alist'
  745. and `inhibit-first-line-modes-suffixes'."
  746.  
  747.   (setq jka-compr-file-name-handler-entry
  748.     (cons (jka-compr-build-file-regexp) 'jka-compr-handler))
  749.  
  750.   (setq file-name-handler-alist (cons jka-compr-file-name-handler-entry
  751.                       file-name-handler-alist))
  752.  
  753.   (mapcar
  754.    (function (lambda (x)
  755.            (and (jka-compr-info-strip-extension x)
  756.             ;; Make entries in auto-mode-alist so that modes
  757.             ;; are chosen right according to the file names
  758.             ;; sans `.gz'.
  759.             (setq auto-mode-alist
  760.               (cons (list (jka-compr-info-regexp x)
  761.                       nil 'jka-compr)
  762.                 auto-mode-alist))
  763.             ;; Also add these regexps to
  764.             ;; inhibit-first-line-modes-suffixes, so that a
  765.             ;; -*- line in the first file of a compressed tar
  766.             ;; file doesn't override tar-mode.
  767.             (setq inhibit-first-line-modes-suffixes
  768.               (cons (jka-compr-info-regexp x)
  769.                 inhibit-first-line-modes-suffixes)))))
  770.    jka-compr-compression-info-list)
  771.   (setq auto-mode-alist
  772.     (append auto-mode-alist jka-compr-mode-alist-additions)))
  773.  
  774.  
  775. (defun jka-compr-uninstall ()
  776.   "Uninstall jka-compr.
  777. This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
  778. and `inhibit-first-line-modes-suffixes' that were added
  779. by `jka-compr-installed'."
  780.   ;; Delete from inhibit-first-line-modes-suffixes
  781.   ;; what jka-compr-install added.
  782.   (mapcar
  783.      (function (lambda (x)
  784.          (and (jka-compr-info-strip-extension x)
  785.               (setq inhibit-first-line-modes-suffixes
  786.                 (delete (jka-compr-info-regexp x)
  787.                     inhibit-first-line-modes-suffixes)))))
  788.      jka-compr-compression-info-list)
  789.  
  790.   (let* ((fnha (cons nil file-name-handler-alist))
  791.      (last fnha))
  792.  
  793.     (while (cdr last)
  794.       (if (eq (cdr (car (cdr last))) 'jka-compr-handler)
  795.       (setcdr last (cdr (cdr last)))
  796.     (setq last (cdr last))))
  797.  
  798.     (setq file-name-handler-alist (cdr fnha)))
  799.  
  800.   (let* ((ama (cons nil auto-mode-alist))
  801.      (last ama)
  802.      entry)
  803.  
  804.     (while (cdr last)
  805.       (setq entry (car (cdr last)))
  806.       (if (or (member entry jka-compr-mode-alist-additions)
  807.           (and (consp (cdr entry))
  808.            (eq (nth 2 entry) 'jka-compr)))
  809.       (setcdr last (cdr (cdr last)))
  810.     (setq last (cdr last))))
  811.     
  812.     (setq auto-mode-alist (cdr ama))))
  813.  
  814.       
  815. (defun jka-compr-installed-p ()
  816.   "Return non-nil if jka-compr is installed.
  817. The return value is the entry in `file-name-handler-alist' for jka-compr."
  818.  
  819.   (let ((fnha file-name-handler-alist)
  820.     (installed nil))
  821.  
  822.     (while (and fnha (not installed))
  823.      (and (eq (cdr (car fnha)) 'jka-compr-handler)
  824.        (setq installed (car fnha)))
  825.       (setq fnha (cdr fnha)))
  826.  
  827.     installed))
  828.  
  829.  
  830. ;;; Add the file I/O hook if it does not already exist.
  831. ;;; Make sure that jka-compr-file-name-handler-entry is eq to the
  832. ;;; entry for jka-compr in file-name-handler-alist.
  833. (and (jka-compr-installed-p)
  834.      (jka-compr-uninstall))
  835.  
  836. (jka-compr-install)
  837.  
  838.  
  839. (provide 'jka-compr)
  840.  
  841. ;; jka-compr.el ends here.
  842.